Delitos en época de COVID19

Row

Tabla de incidencia

Tipo de delito Incidencia en 2019 Incidencia en 2020 Porcentaje de cambio
Acoso sexual 4204 5597 33.14
Otros delitos que atentan contra la libertad y la seguridad sexual 6325 8032 26.99
Violación equiparada 3674 4225 15
Violencia familiar 210158 220039 4.7
Trata de personas 544 550 1.1
Feminicidio 943 939 -0.42
Homicidio doloso 29456 28808 -2.2
Abuso sexual 23625 22379 -5.27
Hostigamiento sexual 1860 1753 -5.75
Violación simple 13656 12320 -9.78
Lesiones dolosas 166440 144280 -13.31
Tráfico de menores 29 21 -27.59
Secuestro 1331 826 -37.94

Delitos sexuales y de género

Todos los delitos

Row

Cambio en la incidencia

Mapa nacional 1 y pruebas realizadas

Row

Mapa nacional de resultados positivos

Row

Pruebas realizadas por estado

Pruebas realizadas por estado

ENTIDAD_FEDERATIVA Numero de pruebas
AGUASCALIENTES 83669
BAJA CALIFORNIA 109438
BAJA CALIFORNIA SUR 92675
CAMPECHE 32135
CHIAPAS 36265
CHIHUAHUA 100949
CIUDAD DE MÉXICO 2276178
COAHUILA DE ZARAGOZA 164667
COLIMA 25447
DURANGO 80202
GUANAJUATO 294574
GUERRERO 86506
HIDALGO 72730
JALISCO 197763
MÉXICO 709195
MICHOACÁN DE OCAMPO 127938
MORELOS 149913
NAYARIT 25268
NUEVO LEÓN 280918
OAXACA 73225
PUEBLA 182839
QUERÉTARO 138142
QUINTANA ROO 53711
SAN LUIS POTOSÍ 168677
SINALOA 85115
SONORA 128110
TABASCO 209823
TAMAULIPAS 145727
TLAXCALA 63568
VERACRUZ DE IGNACIO DE LA LLAVE 126399
YUCATÁN 98027
ZACATECAS 62854

Mapa porcentaje de positividad

Row

Porcentaje total

Row

Porcentaje 2020

Porcentaje 2021

Ranking Nacional

Calificación por estado para manejo de la pandemia

ESTADO AVERAGE
CHIAPAS 100.00000
CAMPECHE 98.97884
NAYARIT 98.66901
COLIMA 97.96023
TLAXCALA 96.81921
QUINTANA ROO 96.35969
AGUASCALIENTES 95.41484
ZACATECAS 94.84375
MORELOS 94.69145
DURANGO 94.52312
GUERRERO 94.26543
HIDALGO 94.01402
YUCATÁN 93.93572
SINALOA 93.82768
OAXACA 93.69715
MICHOACÁN DE OCAMPO 93.24411
BAJA CALIFORNIA SUR 92.30196
BAJA CALIFORNIA 92.18172
CHIHUAHUA 91.37015
VERACRUZ DE IGNACIO DE LA LLAVE 91.22712
TAMAULIPAS 91.01190
SAN LUIS POTOSÍ 89.47762
TABASCO 88.70702
COAHUILA DE ZARAGOZA 88.65109
QUERÉTARO 88.22406
SONORA 87.45381
PUEBLA 87.04138
JALISCO 86.95819
NUEVO LEÓN 80.84691
GUANAJUATO 79.86316
MÉXICO 60.78769
CIUDAD DE MÉXICO 0.00000

Comparativa entre países (Contagios)

Column

Escenario mundial (población similar)

Column

Escenario LATAM

Vacunación en LATAM

Row

Escenario general

Estacionalidad (Mensual)

Estacionalidad (semanal por mes)

Vacunación en LATAM (Pronósticos)

Row

TSLM

ETS

---
title: "COVID19 Dashboard"
output: 
  flexdashboard::flex_dashboard:
    orientation: rows
    vertical_layout: fill
    social: [ "twitter", "facebook", "menu"]
    source_code: embed
---

```{r setup, include=FALSE}
library(flexdashboard)
# library(knitr)

#integrar visualización
library(patchwork)

library(DT)
library(rpivotTable)
library(ggplot2)
library(plotly)
library(dplyr)
library(openintro)
library(highcharter)
library(ggvis)
library(tidyverse)
# library(tibbletime)
library(reactable)
library(htmltools)
library(fpp3)
library(feasts)
library(fable)
library(tsibble)
library(lubridate)
library(kableExtra)
library(formattable)
#importación y lectura
library(readxl)
library(tidyr)
library(vroom)
#Mapas
library(leaflet)
library(ggmap) # -> para obtener lon y lat de los municipios
library(raster)
library(spData)
library(tmap)
library(RJSONIO)
library(tmaptools)
library(Hmisc)
library(mxmaps) #se instala con un repo de gitgub con el 
                #siguiente comando
                #if (!require("devtools")) {
#     install.packages("devtools")
# }
# devtools::install_github("diegovalle/mxmaps")

library(sf)
library(scales) # needed for comma
library(rgeos)
library(maptools)
library(leaflet)
library(geojsonio)
library(jsonlite)

```


```{r}
# 
# data <- read_csv("VehicleFailure.csv")
  
delitos <- read_csv("../Delitos/delitos2015-2021.csv", 
                    locale(encoding = "latin1"),
                    col_names = TRUE, 
                    col_types = NULL
                 )
  #######Quedarse solo con las columnas y filas necesarias#######

delitos_a_comparar <- c("Feminicidio", "Abuso sexual", 
                        "Acoso sexual", "Hostigamiento sexual",
                        "Otros delitos que atentan contra la libertad y la seguridad sexual",
                        "Violación simple", "Violación equiparada", "Trata de personas",
                        "Tráfico de menores", "Secuestro", "Violencia familiar")

delitos_tidy <- delitos %>%
  filter( Tipo_de_delito %in% delitos_a_comparar | 
          Subtipo_de_delito == "Homicidio doloso" |
          Subtipo_de_delito == "Lesiones dolosas" ) %>% 
  pivot_longer(
  cols = Enero:Diciembre ,
  names_to = "Meses",
  values_to = "Cuenta"
) %>% 
  group_by(Ano, Meses, Tipo_de_delito, Subtipo_de_delito) %>% 
  summarise(Cuenta = sum(Cuenta), .groups = "drop")

delitos_tidy <- delitos_tidy %>% 
  mutate(
    Meses = str_trunc(Meses, width = 3, ellipsis = ""),
    Meses = case_when(
      Meses == "Ene" ~ "Jan",
      Meses == "Abr" ~ "Apr",
      Meses == "Ago" ~ "Aug",
      Meses == "Dic" ~ "Dec",
      TRUE           ~ Meses
    )
  ) %>% 
  unite(col = "Fecha", c(Ano,Meses), sep = " ") %>% 
  mutate(Fecha = yearmonth(Fecha))

delitos_tidy_tsbl <- delitos_tidy %>% 
  as_tsibble(
    index = Fecha,
    key   = c(Tipo_de_delito, Subtipo_de_delito)
  )
# 
# mycolors <- c("blue", "#FFC125", "darkgreen", "darkorange")
```

Delitos en época de COVID19
=====================================



























































Row
-------------------------------

### Tabla de incidencia

```{r}


#Tabla de incidencia (old)
# 
# Incidencia_2019 <-delitos_tidy_tsbl %>% 
#   tsibble::group_by_key() %>% 
#   tsibble::index_by(Año = year(Fecha)) %>% 
#   dplyr::summarise(Cuenta = sum(Cuenta)) %>% 
#   dplyr::filter(Año %in% 2019) %>%
#   dplyr::as_tibble(Incidencia_2019) %>%
#   dplyr::transmute( Delito = Tipo_de_delito, 
#                     Incidencia_2019 = Cuenta) 
# 
# Incidencia_2020 <- delitos_tidy_tsbl %>%
#   group_by_key() %>%
#   
#   index_by(Año = year(Fecha)) %>%
#   
#   dplyr::summarise(Cuenta = sum(Cuenta)) %>%
#   dplyr::filter(Año %in% 2020) %>%
#   dplyr::as_tibble(Incidencia_2020) %>%
#   dplyr::mutate(Delito = Tipo_de_delito,
#         Incidencia_2020 = Cuenta) %>%
#   dplyr::select(Delito, Incidencia_2020)
# 
# Incidencia <- Incidencia_2020 %>%
#   add_column(Incidencia_2019$Incidencia_2019) %>%
#   dplyr::mutate(
#     Porcentaje_de_cambio = round((
#       (Incidencia_2020 - Incidencia_2019$Incidencia_2019)/Incidencia_2020), digits = 5),
#     Incidencia_2019 = Incidencia_2019$Incidencia_2019) %>%
#   
#   dplyr::select(Delito, Incidencia_2019, Incidencia_2020, Porcentaje_de_cambio)%>%
#   arrange(desc(Porcentaje_de_cambio)) 
#  
# Tabla <- Incidencia %>%
#   mutate(Porcentaje_de_cambio =  percent(Porcentaje_de_cambio, 2)) %>%
#   kbl(fortmat = "htlm", col.names = c("Delitos",
#                                       "Incidencia en 2019",
#                                       "Incidencia en 2020",
#                                       "Porcentaje de cambio")) %>%
#   
#   kable_styling(bootstrap_options = "striped",
#                 full_width = F,
#                 position = "left",
#                 font_size = 14) %>%
#   
#   column_spec(4,color = ifelse( Incidencia$Porcentaje_de_cambio > 0, "red", "green"))
# Tabla


#Tabla de incidencia (new -> 13/marzo/2021)

incidencias <- delitos_tidy_tsbl %>% 
  group_by_key() %>% 
  index_by(Año = year(Fecha)) %>% 
  summarise(Cuenta = sum(Cuenta)) %>% 
  as_tibble(incidencias) %>% 
  mutate(cambio = (Cuenta / lag(Cuenta) - 1)*100) %>% 
  filter(Año != 2021)

Todos_delitos_gg <- incidencias %>% 
  ggplot(aes(x = Año, y = Cuenta, color = Tipo_de_delito)) +
  geom_line(size = 1)+
  facet_wrap(~ Tipo_de_delito, scales = "free_y") +
  theme(legend.position = "none")

# perc_cambio_incidencias <- incidencias %>%
#   ggplot(aes(x = Año, y = cambio, color = Subtipo_de_delito)) +
#   geom_line() +
#   geom_line(size = 1)+
#   facet_wrap(~ Subtipo_de_delito, scales = "free_y") +
#   theme(legend.position = "none")
# plotly::ggplotly(perc_cambio_incidencias)

incidencias <- incidencias %>% 
  pivot_wider(names_from = Año, values_from = Cuenta:cambio)

Tabla <- incidencias %>%
  dplyr::select( Subtipo_de_delito, Cuenta_2019, Cuenta_2020, cambio_2020) %>%
  arrange(-cambio_2020) %>%
  transmute('Tipo de delito' = Subtipo_de_delito,
            'Incidencia en 2019' = Cuenta_2019,
            'Incidencia en 2020' = Cuenta_2020,
            'Porcentaje de cambio' =  round(cambio_2020, digits = 2))

customGreen0 = "#DeF7E9"

customGreen = "#71CA97"

customRed = "#ff7f7f"

cambio_format <- 
  formatter("span", 
            style = x ~ formattable::style(
              font.weight = "bold",
              color = ifelse(x < 0, customGreen, ifelse(x > 0, customRed, "black"))),
            x ~ icontext(ifelse(x>0, "arrow-up", "arrow-down"), x)
  ) 

formattable(Tabla, 
            align = c("l", rep("r", NCOL(Tabla) - 1)),
            list('Tipo de delito' = formatter("span", style = ~ formattable::style(color = "grey", font.weight = "bold")),
                 'Porcentaje de cambio' = cambio_format
            ))
 


```


### Delitos sexuales y de género

```{r}

sexuales_y_genero = c("Abuso sexual", 
                      "Acoso sexual",
                      "Feminicidio", 
                      "Violación simple", 
                      "Violación equiparada", 
                      "Hostigamiento sexual", 
                      "Otros delitos que atentan contra la libertad y la seguridad sexual")

# Grafica old
# p2 <-  delitos_tidy_tsbl %>%
#   filter (Tipo_de_delito %in% sexuales_y_genero) %>%
#   ggplot() + 
#   geom_line(mapping = aes(x = Fecha, y = Cuenta, color = Tipo_de_delito))
# 
# p2

delitos_sexuales_y_genero_gg <- delitos_tidy_tsbl %>%
  filter (Tipo_de_delito %in% sexuales_y_genero) %>%
  ggplot(aes(x = Fecha, y = Cuenta, color = Tipo_de_delito)) +
  geom_line(size = 1)+
  facet_wrap(~ Tipo_de_delito, scales = "free_y") +
  theme(legend.position = "none")

delitos_sexuales_y_genero_gg
```

```{r}
#CargaDeDatos para generar gráficas de los delitos totales y en tasa de cambio

incidencias <- delitos_tidy_tsbl %>% 
  group_by_key() %>% 
  index_by(Anual = year(Fecha)) %>% 
  summarise(Cuenta = sum(Cuenta)) %>% 
  as_tibble(incidencias) %>% 
  mutate(cambio = (Cuenta / lag(Cuenta) - 1)*100) %>% 
  filter(Anual != 2021)

```


### Todos los delitos

```{r}
#gráfica old, delitos contra la libertad
# p3 <- delitos_tidy_tsbl %>%
#   filter (Tipo_de_delito %in% c("Trata de personas", "Tráfico de menores", "Secuestro") ) %>%
#   ggplot() + 
#   geom_line(mapping = aes(x = Fecha, y = Cuenta, color = Tipo_de_delito))
# 
# p3

Todos_delitos_gg <- incidencias %>% 
  ggplot(aes(x = Anual, y = Cuenta, color = Tipo_de_delito)) +
  geom_line(size = 1)+
  facet_wrap(~ Tipo_de_delito, scales = "free_y") +
  theme(legend.position = "none")

Todos_delitos_gg
```

Row
------------------------------------
### Cambio en la incidencia  

```{r}
# gráfica old, delitos dolosos 
# p4 <- delitos_tidy_tsbl %>%
#   filter(Subtipo_de_delito %in% c("Lesiones dolosas", "Homicidio doloso")) %>%
#   ggplot() + 
#   geom_line(mapping = aes(x = Fecha, y = Cuenta, color = Tipo_de_delito))
# 
# p4

perc_cambio_incidencias <- incidencias %>%
  ggplot(aes(x = Anual, y = cambio, color = Subtipo_de_delito)) +
  geom_line() +
  geom_line(size = 1)+
  facet_wrap(~ Subtipo_de_delito, scales = "free_y") +
  theme(legend.position = "none")
plotly::ggplotly(perc_cambio_incidencias)
```













Mapa nacional 1 y pruebas realizadas
========================================

Row
------------------------------------

### Mapa nacional de resultados positivos 

```{r}
# car <- data %>%
#          group_by(State) %>%
#          summarize(total = n())
# car$State <- abbr2state(car$State)
# 
# highchart() %>%
#          hc_title(text = "Car Failures in US") %>%
#          hc_subtitle(text = "Source: Vehiclefailure.csv") %>%
#          hc_add_series_map(usgeojson, car,
#                            name = "State",
#                            value = "total",
#                            joinBy = c("woename", "State")) %>%

#          hc_mapNavigation(enabled = T)
# lubridate::today()-1
# fecha <- "210415"



options(timeout = 700)
temp <- tempfile()
download.file("http://datosabiertos.salud.gob.mx/gobmx/salud/datos_abiertos/datos_abiertos_covid19.zip", temp)


Datosmex2502 <- vroom::vroom(unz(temp, unzip(temp, list = TRUE) %>% pull(Name)))
unlink(temp)

```


```{r}
Entidades <- read_xlsx("../Datos nacionales abiertos/201128 Catalogos.xlsx",sheet="Catálogo de ENTIDADES")

# Clasificación de datos  -------------------------------------------------

#datos necesarios para la prueba
datosimportates <- dplyr::select(Datosmex2502,`FECHA_INGRESO`,`ENTIDAD_RES`,
                                 `TOMA_MUESTRA_LAB`,`RESULTADO_LAB`, `TOMA_MUESTRA_ANTIGENO`,
                                 `RESULTADO_ANTIGENO`, `CLASIFICACION_FINAL`)%>%
  left_join(Entidades, by=c("ENTIDAD_RES"="CLAVE_ENTIDAD"))

#datos confirmados sin realización de pruebas
confirmados <- datosimportates %>% 
  filter(`CLASIFICACION_FINAL`%in% c(1,2,3)) %>% 
  dplyr::select(`FECHA_INGRESO`, `ENTIDAD_RES`, `ENTIDAD_FEDERATIVA`, `ABREVIATURA`) %>% 
  mutate(
    year = lubridate::year(FECHA_INGRESO),
    month = lubridate::month(FECHA_INGRESO),
    day = lubridate::day(FECHA_INGRESO)
  ) %>% 
  drop_na(`ENTIDAD_FEDERATIVA`, `FECHA_INGRESO`) 

# Agrupación de datos  ----------------------------------------------------
#Numero de positivos por estado
positivosestado <- confirmados %>%
  group_by(`ENTIDAD_RES`) %>%
  summarise(
    count=n(),
  )

#Selección de nombre estados, por orden de codigo
nombreEstado <- Entidades %>%
  dplyr::select(`ENTIDAD_FEDERATIVA`) %>%
  slice( 1:32)

mapaPositivos <- positivosestado %>%
  add_column(nombreEstado)

# Mapa  -------------------------------------------------------------------

# data(mapaPositivos)
# mapaPositivos$rand <- mapaPositivos$count
# mapaPositivos$region <- mapaPositivos$ENTIDAD_RES
# mxstate_choropleth(mapaPositivos,
#                    title = "Casos confirmados de COVID por estado.",
#                    legend = "Número de casos.",
# )


# Convert the topoJSON to spatial object
tmpdir <- tempdir()
# have to use RJSONIO or else the topojson isn't valid
write(RJSONIO::toJSON(mxstate.topoJSON), file.path(tmpdir, "sta.topojson"))
mxstate <- topojson_read(file.path(tmpdir, "sta.topojson")) 


#ordenamos los datos del topoJSON en orden numérico
mxstate <- mxstate[order(mxstate$id),]


mxstate <- as_Spatial(mxstate)

mxstate$rand <- mapaPositivos$count

bins <- c(5000,20000 , 30000, 35000, 50000, 60000, 115000,300000, Inf)
pal <- colorBin("YlOrRd", domain = mxstate$rand, bins=bins)


etiqueta <- paste(
  "Estado: ", mapaPositivos$ENTIDAD_FEDERATIVA, "
", "Número de casos: ", mapaPositivos$count ) %>% lapply(htmltools::HTML) leaflet(mxstate) %>% addPolygons( fillColor = ~pal(mxstate$rand), fillOpacity = 1, stroke = TRUE, color = "White", weight = 1.5, dashArray = "3", highlight = highlightOptions( weight = 5, color = "#666", dashArray = "", fillOpacity = 0.7, bringToFront = TRUE), label = etiqueta, )%>% addLegend(pal = pal, values = ~mapaPositivos$rand, opacity = 0.7, title = "Casos
positivos
contagios", position = "bottomright")%>% addTiles() %>% addMarkers(50, 50) %>% addControl("Positivos totales COVID19 México", position = "bottomleft") %>% addProviderTiles("CartoDB.Positron") ``` Row ------------------------------------ ### Pruebas realizadas por estado ```{r} # # Importación de datos ---------------------------------------------------- # # # # Datosmex2502 <- read_csv("210225COVID19MEXICO.csv") # # Descarga de datos desde la página web # fecha <- "210412" # options(timeout = 600) # temp <- tempfile() # download.file("http://datosabiertos.salud.gob.mx/gobmx/salud/datos_abiertos/datos_abiertos_covid19.zip", temp) # # # Datosmex2502 <- vroom::vroom(unz(temp, paste0(fecha,"COVID19MEXICO.csv"))) # unlink(temp) # # # Entidades <- read_xlsx("Datos nacionales abiertos/201128 Catalogos.xlsx",sheet="Catálogo de ENTIDADES") # # Clásificación ---------------------------------------------------------- # # #datos necesarios para la prueba # datosimportates <- dplyr::select(Datosmex2502,`FECHA_INGRESO`,`ENTIDAD_RES`, # `TOMA_MUESTRA_LAB`,`RESULTADO_LAB`, `TOMA_MUESTRA_ANTIGENO`, # `RESULTADO_ANTIGENO`, `CLASIFICACION_FINAL`)%>% # left_join(Entidades, by=c("ENTIDAD_RES"="CLAVE_ENTIDAD")) #datos de las pruebas realizadas ese día en todo el país pruebasfiltro <- datosimportates %>% dplyr::filter(`TOMA_MUESTRA_LAB`== 1 | `TOMA_MUESTRA_ANTIGENO`==1 ) %>% dplyr::select(`FECHA_INGRESO`, `ENTIDAD_RES`,`ENTIDAD_FEDERATIVA`,`ABREVIATURA`) %>% mutate( year = lubridate::year(FECHA_INGRESO), month = lubridate::month(FECHA_INGRESO), day = lubridate::day(FECHA_INGRESO) ) %>% drop_na(`ENTIDAD_FEDERATIVA`, `FECHA_INGRESO`) # Agrupación de datos ---------------------------------------------------- #Numero de pruebas por estado totales hasta la fecha de datos pruebasXEstado <- pruebasfiltro %>% group_by(`ENTIDAD_FEDERATIVA`) %>% mutate(`Numero de pruebas`=n()) %>% distinct(`ENTIDAD_FEDERATIVA`, .keep_all = TRUE) %>% arrange(`ENTIDAD_FEDERATIVA`) %>% drop_na(`ENTIDAD_FEDERATIVA`) pruebasXEstado <- pruebasXEstado %>% dplyr::select( `ENTIDAD_FEDERATIVA`, `Numero de pruebas` ) pruebasfiltro$FECHA_INGRESO <- format(pruebasfiltro$FECHA_INGRESO, "%Y-%m") #Numero de pruebas por estado según el día pruebasxEstadoxDia <- pruebasfiltro %>% group_by(`ENTIDAD_RES`, `FECHA_INGRESO`) %>% mutate(count=n()) %>% distinct(`ENTIDAD_RES`, .keep_all = TRUE) %>% arrange(`ENTIDAD_RES`) %>% drop_na(`ENTIDAD_FEDERATIVA`) # Gráfica ---------------------------------------------------------------- ggplot(data = pruebasfiltro) + geom_bar(mapping = aes(y = FECHA_INGRESO, fill = ABREVIATURA), position = "dodge") ``` ### Pruebas realizadas por estado ```{r} # Tabla ------------------------------------------------------------------ #Tabla que muestra el número de pruebas que se hacen por día en los estados formattable(pruebasXEstado, #llamo datos align =c("l","c"), #Para alinear los datos de la tabla cada "" es una columna list(`ENTIDAD_FEDERATIVA` = formatter( #datos específicos "span", style = ~ style(color = "grey",font.weight = "bold")), `Numero de pruebas` = color_bar("Red") # me crea una barra roja con proporción a los datos ) ) ``` Mapa porcentaje de positividad ======================================== Row ------------------------------------ ### Porcentaje total ```{r} # Importación de datos ---------------------------------------------------- #Datosmex2502 <- read_csv("210225COVID19MEXICO.csv") # Descarga de datos desde la página web # fecha <- "210414" # options(timeout = 700) # temp <- tempfile() # download.file("http://datosabiertos.salud.gob.mx/gobmx/salud/datos_abiertos/datos_abiertos_covid19.zip", temp) # # # Datosmex2502 <- vroom::vroom(unz(temp, unzip(temp, list = TRUE) %>% pull(Name))) # unlink(temp) # # # Entidades <- read_xlsx("Datos nacionales abiertos/201128 Catalogos.xlsx",sheet="Catálogo de ENTIDADES") # # # Clasificación de datos ------------------------------------------------- # # #datos necesarios para la prueba # datosimportates <- dplyr::select(Datosmex2502,`FECHA_INGRESO`,`ENTIDAD_RES`, # `TOMA_MUESTRA_LAB`,`RESULTADO_LAB`, `TOMA_MUESTRA_ANTIGENO`, # `RESULTADO_ANTIGENO`, `CLASIFICACION_FINAL`)%>% # left_join(Entidades, by=c("ENTIDAD_RES"="CLAVE_ENTIDAD")) # # # # #datos confirmados sin realización de pruebas # confirmados <- datosimportates %>% # filter(`CLASIFICACION_FINAL`%in% c(1,2,3)) %>% # dplyr::select(`FECHA_INGRESO`, `ENTIDAD_RES`, `ENTIDAD_FEDERATIVA`, `ABREVIATURA`) %>% # mutate( # year = lubridate::year(FECHA_INGRESO), # month = lubridate::month(FECHA_INGRESO), # day = lubridate::day(FECHA_INGRESO) # ) %>% # drop_na(`ENTIDAD_FEDERATIVA`, `FECHA_INGRESO`) #datos de las pruebas realizadas ese día en todo el país pruebasfiltro <- datosimportates %>% dplyr::filter(`TOMA_MUESTRA_LAB`== 1 | `TOMA_MUESTRA_ANTIGENO`==1 ) %>% dplyr::select(`FECHA_INGRESO`, `ENTIDAD_RES`,`ENTIDAD_FEDERATIVA`,`ABREVIATURA`) %>% mutate( year = lubridate::year(FECHA_INGRESO), month = lubridate::month(FECHA_INGRESO), day = lubridate::day(FECHA_INGRESO) ) %>% drop_na(`ENTIDAD_FEDERATIVA`, `FECHA_INGRESO`) #Separación de datos por fechas para mapas pruebas2020 <- dplyr::filter(pruebasfiltro, year==2020) pruebEstado2020 <- pruebas2020 %>% group_by(`ENTIDAD_RES`) %>% summarise( count=n() ) pruebas2021 <- dplyr::filter(pruebasfiltro, year==2021) pruebEstado2021 <- pruebas2021 %>% group_by(`ENTIDAD_RES`) %>% summarise( count=n() ) #confirmados por año para mapas confirm2020 <- confirmados %>% dplyr::filter( year==2020) %>% drop_na(`ENTIDAD_FEDERATIVA`) confirmEstado2020 <- confirm2020 %>% group_by(`ENTIDAD_RES`) %>% summarise( count=n() ) confirm2021 <- confirmados %>% dplyr::filter( year==2021) %>% drop_na(`ENTIDAD_FEDERATIVA`) confirmEstado2021 <- confirm2021 %>% group_by(`ENTIDAD_RES`) %>% summarise( count=n() ) #Numero de pruebas por estado totales hasta la fecha de datos pruebasXEstado <- pruebasfiltro %>% group_by(`ENTIDAD_RES`) %>% mutate(PRUEBAS=n()) %>% distinct(`ENTIDAD_RES`, .keep_all = TRUE) %>% arrange(`ENTIDAD_RES`) %>% drop_na() # #Numero de pruebas por estado según el día # pruebasxEstadoxDia <- pruebasfiltro %>% # group_by(`ENTIDAD_RES`,`FECHA_INGRESO`) %>% # mutate(count=n()) %>% # distinct(`ENTIDAD_RES`, .keep_all = TRUE) %>% # arrange(`ENTIDAD_RES`) %>% # drop_na() # # # prubeasXEstadotsbl <- pruebasxEstadoxDia %>% # as_tsibble( key = `ENTIDAD_RES`, # index = `FECHA_INGRESO` # ) # group_split(pruebasxEstadoxDia) # group_keys(pruebasxEstadoxDia) #Positivos por estado totales hasta la fecha de datos positivoxEstado <- confirmados %>% group_by(`ENTIDAD_RES`) %>% mutate(CONFIRMADOS=n()) %>% distinct(`ENTIDAD_RES`, .keep_all = TRUE) %>% arrange(`ENTIDAD_RES`) %>% dplyr::select(ENTIDAD_RES, ENTIDAD_FEDERATIVA, CONFIRMADOS ) # #Positivos por estado según el día # positivoxEstadoxDia <- confirmados %>% # group_by(`ENTIDAD_RES`, `FECHA_INGRESO`) %>% # mutate(count=n()) %>% # distinct(`ENTIDAD_RES`, .keep_all = TRUE) %>% # arrange(`ENTIDAD_RES`) %>% # drop_na() # # positivoXDiatsbl <- positivoxEstadoxDia %>% # as_tsibble( key = ENTIDAD_RES, # index = FECHA_INGRESO # # ) #Selección de nombre estados, por orden de codigo nombreEstado <- Entidades %>% dplyr::select(`ENTIDAD_FEDERATIVA`) %>% slice( 1:32) # Agrupación de datos totales ----------------------------------------------------- # #suma total de las pruebas realizadas totalpruebas <- pruebasXEstado$PRUEBAS %>% sum(na.rm = TRUE) #suma total de las pruebas que salieron positivas totalpositivas <- positivoxEstado$CONFIRMADOS %>% sum(na.rm = TRUE) #Porcentaje por estado de las pruebas positivas a el total de pruebas realizadas en los estados positividadPais <- (totalpositivas/totalpruebas)*100 #positividadPais positividad <- ((positivoxEstado$CONFIRMADOS/pruebasXEstado$PRUEBAS)*100) #positividad #porcentaje total de las pruebas positivas de acuerdo a que estado. porcenestado <- (positivoxEstado$CONFIRMADOS/totalpositivas)*100 porcenestado <- as.numeric(porcenestado) #porcenestado #Porcentaje total de pruebas positvas porcen <- sum(positividad, na.rm = TRUE) #verificación de suma de porcentaje de pruebas positivas (porcenestado) sumporcentaje <- sum(porcenestado, na.rm = TRUE) # creamos tibble con datos de codigo de entidad y casos positivos nueva <- positivoxEstado %>% #agregamos porcentajes de acuerdo al total de pruebas positivas add_column(porcenestado)%>% #agregamos porcentajes del total de pruebas add_column(positividad) %>% add_column(pruebasXEstado$PRUEBAS) # #Agregamos el nombre de los estados por orden de codigo # add_column(nombreEstado) # Agrupación de datos 2020 ------------------------------------------------ # #suma total de las pruebas realizadas # totalpruebas2020 <- pruebEstado2020$count %>% # sum(na.rm = TRUE) #suma total de las pruebas que salieron positivas totalpositivas2020 <- confirmEstado2020$count %>% sum(na.rm = TRUE) #Porcentaje por estado de las pruebas positivas a el total de pruebas realizadas en los estados positividad2020 <- (confirmEstado2020$count/pruebEstado2020$count)*100 #positividad2020 #porcentaje total de las pruebas positivas de acuerdo a que estado. porcenestado2020 <- (confirmEstado2020$count/totalpositivas2020)*100 porcenestado2020 <- as.numeric(porcenestado) #porcenestado2020 #Porcentaje total de pruebas positvas porcen2020 <- sum(positividad2020, na.rm = TRUE) #verificación de suma de porcentaje de pruebas positivas (porcenestado) sumporcentaje2020 <- sum(porcenestado2020, na.rm = TRUE) # creamos tibble con datos de codigo de entidad y casos positivos nueva2020 <- confirmEstado2020 %>% #agregamos porcentajes de acuerdo al total de pruebas positivas add_column(porcenestado2020)%>% #agregamos porcentajes del total de pruebas add_column(positividad2020) %>% #Agregamos el nombre de los estados por orden de codigo add_column(nombreEstado) # Agrupación de datos 2021 ------------------------------------------------ # #suma total de las pruebas realizadas # totalpruebas2021 <- pruebEstado2021$count %>% # sum(na.rm = TRUE) #suma total de las pruebas que salieron positivas totalpositivas2021 <- confirmEstado2021$count %>% sum(na.rm = TRUE) #Porcentaje por estado de las pruebas positivas a el total de pruebas realizadas en los estados positividad2021 <- (confirmEstado2021$count/pruebEstado2021$count)*100 #positividad2021 #porcentaje total de las pruebas positivas de acuerdo a que estado. porcenestado2021 <- (confirmEstado2021$count/totalpositivas2021)*100 porcenestado2021 <- as.numeric(porcenestado2021) #porcenestado2021 #Porcentaje total de pruebas positvas porcen2021 <- sum(positividad2021, na.rm = TRUE) #verificación de suma de porcentaje de pruebas positivas (porcenestado) sumporcentaje2021 <- sum(porcenestado2021, na.rm = TRUE) # creamos tibble con datos de codigo de entidad y casos positivos nueva2021 <- confirmEstado2021 %>% #agregamos porcentajes de acuerdo al total de pruebas positivas add_column(porcenestado2021)%>% #agregamos porcentajes del total de pruebas add_column(positividad2021) %>% #Agregamos el nombre de los estados por orden de codigo add_column(nombreEstado) # Mapa de positividad total -------------------------------------------------------------------- # de acuerdo al número de pruebas realizadas se calcula el porcentaje de las #pruebas que fueron seleccionadas como positivas. (por estado) #data(nueva) nueva$value <- nueva$positividad nueva$region <- nueva$ENTIDAD_RES # mxstate_choropleth(nueva, # num_colors = 1, # title = "Porcentaje de casos positivos", # legend = "%", # ) #Mapa interactivo bins = c(15, 18, 21, 24, 27, 30, 33, 36, 39, 42, 45, 48, 51, 54, 57, 60, 63, 66, 69, 72) pal <- colorBin("viridis", domain = nueva$value, bins=bins) mxstate_leaflet(nueva, pal, ~ pal(value), ~ sprintf("Estado: %s
Porcentaje de positividad : %s", ENTIDAD_FEDERATIVA , comma(value) )) %>% addLegend(position = "bottomright", pal = pal, values = nueva$value, title = "Percentaje
Positividad", labFormat = labelFormat(suffix = "%", )) %>% addTiles() %>% addMarkers(50, 50) %>% addControl("Mapa positividad de las pruebas totales", position = "bottomleft") %>% addProviderTiles("CartoDB.Positron") ``` Row ------------------------------------ ### Porcentaje 2020 ```{r} # Mapa 2020 --------------------------------------------------------------- # de acuerdo al número de pruebas realizadas se calcula el porcentaje de las #pruebas que fueron seleccionadas como positivas. (por estado del año 2020) data(nueva2020) nueva2020$value <- nueva2020$positividad2020 nueva2020$region <- nueva2020$ENTIDAD_RES # mxstate_choropleth(nueva, # num_colors = 1, # title = "Porcentaje de casos positivos", # legend = "%", # ) #Mapa interactivo bins=c(15, 18, 21, 24, 27, 30, 33, 36, 39, 42, 45, 48, 51, 54, 57, 60, 63, 66, 69, 72) pal <- colorBin("viridis", domain = nueva2020$value, bins=bins) mxstate_leaflet(nueva2020, pal, ~ pal(value), ~ sprintf("Estado: %s
Porcentaje de positividad : %s", ENTIDAD_FEDERATIVA , comma(value) )) %>% addLegend(position = "bottomright", pal = pal, values = nueva2020$value, title = "Percentaje
Positividad", labFormat = labelFormat(suffix = "%", )) %>% addTiles() %>% addMarkers(50, 50) %>% addControl("Mapa positividad de las pruebas en 2020", position = "bottomleft") %>% addProviderTiles("CartoDB.Positron") ``` ### Porcentaje 2021 ```{r} # Mapa 2021 --------------------------------------------------------------- # de acuerdo al número de pruebas realizadas se calcula el porcentaje de las #pruebas que fueron seleccionadas como positivas. (por estado del año 2021) data(nueva2021) nueva2021$value <- nueva2021$positividad2021 nueva2021$region <- nueva2021$ENTIDAD_RES # mxstate_choropleth(nueva2021, # num_colors = 1, # title = "Porcentaje de casos positivos", # legend = "%", # ) #Mapa interactivo bins = c(15, 18, 21, 24, 27, 30, 33, 36, 39, 42, 45, 48, 51, 54, 57, 60, 63, 66, 69, 72) pal <- colorBin("viridis", domain = nueva2021$value, bins=bins) mxstate_leaflet(nueva2021, pal, ~ pal(value), ~ sprintf("Estado: %s
Porcentaje de positividad : %s", ENTIDAD_FEDERATIVA , comma(value) )) %>% addLegend(position = "bottomright", pal = pal, values = nueva2021$value, title = "Percentaje
Positividad", labFormat = labelFormat(suffix = "%", )) %>% addTiles() %>% addMarkers(50, 50) %>% addControl("Mapa positividad de pruebas en 2021", position = "bottomleft") %>% addProviderTiles("CartoDB.Positron") ``` ```{r} # Carga de datos ---------------------------------------------------------- #Se importan los datos como un tibble Vacunastotales <- readr::read_csv("https://raw.githubusercontent.com/owid/covid-19-data/master/public/data/vaccinations/vaccinations.csv") # Wrangle data ------------------------------------------------------------ #Se quiere trabajar con series de tiempo, entonces convertimos # a tsibble un objeto que tiene orientación a este tiempo de #procesamiento Vacunastotales_tsibble <- Vacunastotales %>% dplyr::mutate(Daily = as.Date(date)) %>% dplyr::select(-date) %>% tsibble::as_tsibble(key = location, index = Daily) #se hace una variable con los nombres de los paises de #LATAM para asi poder llamar la variable a buscar en #la base de datos si se requiere, esto esta pensado #en que la instrucción podría hacerse varias veces #entonces en teoría debería simplificar el código latam <- c("Mexico", "Argentina", "Colombia", "Chile", "Brazil", "Bolivia", "Costa Rica", "Ecuador", "Guatemala", "Panama", "Paraguay", "Peru", "Puerto Rico", "Dominican Republic") #Se encontro que era particularmente complicado mostrar #todos los datos en una sola gráfica, por lo tanto, #graficar por secciones y pegar con patchwork es una #opción viable, por lo que la variable length(latam) = 14 #entonces dividimos en 2 grupos para tener símetria. latam1 <- latam[1:7] latam2 <- latam[8:14] #latam == latam1 + latam2 #hacemos otro dafa frame que solo sea para los de #LATAM y asi trabajamos con un tsibble más pequeña Vacunas_latam_tsibble <- Vacunastotales_tsibble %>% dplyr::select( Daily, location, total_vaccinations, total_vaccinations_per_hundred, daily_vaccinations_per_million) %>% filter(location %in% latam) ``` Ranking Nacional ========================================= ### Calificación por estado para manejo de la pandemia ```{r echo = FALSE, results= 'hide'} # # Importación de datos ---------------------------------------------------- # # # Descarga de datos desde la página web # # fecha <- "210415" # options(timeout = 700) # temp <- tempfile() # download.file("http://datosabiertos.salud.gob.mx/gobmx/salud/datos_abiertos/datos_abiertos_covid19.zip", temp) # # # Datosmex2502 <- vroom::vroom(unz(temp, unzip(temp, list = TRUE) %>% pull(Name))) # unlink(temp) # # Entidades <- read_xlsx("Datos nacionales abiertos/201128 Catalogos.xlsx",sheet="Catálogo de ENTIDADES") # Selección de datos ------------------------------------------------------ #datos necesarios para la prueba FiltImpoData <- dplyr::select(Datosmex2502, `FECHA_INGRESO`, `ENTIDAD_RES`, `TOMA_MUESTRA_LAB`, `RESULTADO_LAB`, `TOMA_MUESTRA_ANTIGENO`, `RESULTADO_ANTIGENO`, `CLASIFICACION_FINAL`, `FECHA_DEF`, )%>% left_join(Entidades, by=c("ENTIDAD_RES"="CLAVE_ENTIDAD")) #Población en cada estado del país, con datos a 2020 poblacionEstado <- dplyr::select(df_mxstate_2020, `region`, `state_name`, `pop`, ) # Filtro de datos en tibbles --------------------------------------------------------- #datos confirmados confirm <- FiltImpoData %>% filter(`CLASIFICACION_FINAL`%in% c(1,2,3)) %>% drop_na(`ENTIDAD_FEDERATIVA`, `FECHA_INGRESO`) %>% #borramos los datos NA que generan más filas(son pocos) arrange(`FECHA_INGRESO`) #Casos terminados en muerte muertesConfirm <- FiltImpoData %>% filter(!is.na(`FECHA_DEF`)) %>% drop_na(`ENTIDAD_FEDERATIVA`, `FECHA_INGRESO`) #quitamos datos NA (no interfiere) #datos de las pruebas realizadas ese día en todo el país filtroPrueba <- FiltImpoData %>% dplyr::filter(`TOMA_MUESTRA_LAB`== 1 | `TOMA_MUESTRA_ANTIGENO`==1 ) %>% #seleccuón de datos con pruebas drop_na(`ENTIDAD_FEDERATIVA`, `FECHA_INGRESO`) #borrar datos NA (no afecta) # Medias moviles de los estados casos positivos ----------------------------------------------------- positivosXEstaXDia <- confirm %>% dplyr::group_by(`ENTIDAD_RES`, `FECHA_INGRESO`) %>% mutate(POSITIVOS=n()) %>% distinct(`FECHA_INGRESO`, .keep_all = TRUE) %>% arrange(`FECHA_INGRESO`) %>% dplyr::select(`FECHA_INGRESO`, `ENTIDAD_RES`, `ENTIDAD_FEDERATIVA`, `FECHA_DEF`, `POSITIVOS`, ) #promedio de los últimos catorce días positivosXEstaXDia %>% group_by(ENTIDAD_FEDERATIVA) %>% slice_tail(n = 14) # %>% # summarise(Promedio = mean(POSITIVOS)) #media movil de 14 días positivos_tsbl <- positivosXEstaXDia %>% ungroup() %>% as_tsibble(index = FECHA_INGRESO, key = ENTIDAD_FEDERATIVA) %>% mutate( `14-MA` = slider::slide_dbl(POSITIVOS, mean, .before = 14, .complete = TRUE) ) # #gráfica de los positivos con la medi movil # positivos_tsbl %>% # feasts::autoplot(POSITIVOS) + # geom_line(aes(y = `14-MA`), color = "black") + # facet_wrap(~ ENTIDAD_FEDERATIVA, scales = "free_y") + # theme(legend.position = "none") # Medias moviles de los estados casos negativos --------------------------- muertesXEstaXDia <- muertesConfirm %>% dplyr::group_by(`ENTIDAD_RES`, `FECHA_INGRESO`) %>% mutate(MUERTES=n()) %>% distinct(`FECHA_INGRESO`, .keep_all = TRUE) %>% arrange(`FECHA_INGRESO`) %>% dplyr::select(`FECHA_INGRESO`, `ENTIDAD_RES`, `ENTIDAD_FEDERATIVA`, `FECHA_DEF`, `MUERTES` ) #promedio de los últimos catorce días muertesXEstaXDia %>% group_by(ENTIDAD_FEDERATIVA) %>% slice_tail(n = 14) # %>% # summarise(Promedio = mean(MUERTES)) #media movil de 14 días muertes_tsbl <- muertesXEstaXDia %>% ungroup() %>% as_tsibble(index = FECHA_INGRESO, key = ENTIDAD_FEDERATIVA) %>% mutate( `14-MA` = slider::slide_dbl(MUERTES, mean, .before = 14, .complete = TRUE) ) # #gráfica de los positivos con la medi movil # muertes_tsbl %>% # feasts::autoplot(MUERTES) + # geom_line(aes(y = `14-MA`), color = "black") + # facet_wrap(~ ENTIDAD_FEDERATIVA, scales = "free_y") + # theme(legend.position = "none") # medias movil positivos por millon de habitantes ------------------------- positivosXEstaXDiaXmillon <- positivosXEstaXDia %>% left_join(poblacionEstado, by=c("ENTIDAD_RES"="region")) positivosXEstaXDiaXmillon$POSITIVOS <- (positivosXEstaXDiaXmillon$POSITIVOS*1000000)/positivosXEstaXDiaXmillon$pop #media movil de 14 días positivosmillon_tsbl <- positivosXEstaXDiaXmillon %>% ungroup() %>% as_tsibble(index = FECHA_INGRESO, key = ENTIDAD_FEDERATIVA) %>% mutate( `14-MA` = slider::slide_dbl(POSITIVOS, mean, .before = 14, .complete = TRUE) ) # media movil muertes por millon de habitantes ---------------------------- muertesXEstaXDiaXmillon <- muertesXEstaXDia %>% left_join(poblacionEstado, by=c("ENTIDAD_RES"="region")) muertesXEstaXDiaXmillon$MUERTES <- (muertesXEstaXDiaXmillon$MUERTES*1000000)/muertesXEstaXDiaXmillon$pop #media movil de 14 días muertesmillon_tsbl <- muertesXEstaXDiaXmillon %>% ungroup() %>% as_tsibble(index = FECHA_INGRESO, key = ENTIDAD_FEDERATIVA) %>% mutate( `14-MA` = slider::slide_dbl(MUERTES, mean, .before = 14, .complete = TRUE) ) # media movil de la positividad ------------------------------------------- PruePosiXEstaXDia <- filtroPrueba %>% dplyr::group_by(`ENTIDAD_RES`, `FECHA_INGRESO`) %>% mutate(PRUEBAS=n()) %>% distinct(`FECHA_INGRESO`, .keep_all = TRUE) %>% arrange(`FECHA_INGRESO`) %>% dplyr::select(`FECHA_INGRESO`, `ENTIDAD_RES`, `ENTIDAD_FEDERATIVA`, `FECHA_DEF`, `PRUEBAS`) %>% left_join(positivosXEstaXDia, positivosXEstaXDia, by= c("ENTIDAD_RES", "FECHA_INGRESO", "ENTIDAD_FEDERATIVA")) PruePosiXEstaXDia$POSITIVIDAD <- (PruePosiXEstaXDia$POSITIVOS/PruePosiXEstaXDia$PRUEBAS)*100 #media movil de 14 días positivdad_tsbl <- PruePosiXEstaXDia %>% ungroup() %>% as_tsibble(index = FECHA_INGRESO, key = ENTIDAD_FEDERATIVA) %>% mutate( `14-MA` = slider::slide_dbl(POSITIVIDAD, mean, .before = 14, .complete = TRUE) ) # Media movil de pruebas por cada 1000 habitantes -------------------------- pruebasXEstaXDia<- filtroPrueba %>% dplyr::group_by(`ENTIDAD_RES`, `FECHA_INGRESO`) %>% mutate(PRUEBAS=n()) %>% distinct(`FECHA_INGRESO`, .keep_all = TRUE) %>% arrange(`FECHA_INGRESO`) %>% dplyr::select(`FECHA_INGRESO`, `ENTIDAD_RES`, `ENTIDAD_FEDERATIVA`, `FECHA_DEF`, `PRUEBAS`) %>% left_join(poblacionEstado, by=c("ENTIDAD_RES"="region")) pruebasXEstaXDia$XMILHAB <- ((1000*pruebasXEstaXDia$PRUEBAS)/pruebasXEstaXDia$pop) #media movil de 14 días pruebas_tsbl <- pruebasXEstaXDia %>% ungroup() %>% as_tsibble(index = FECHA_INGRESO, key = ENTIDAD_FEDERATIVA) %>% mutate( `14-MA` = slider::slide_dbl(XMILHAB, mean, .before = 14, .complete = TRUE) ) # Indicadores por día en cada estado ------------------------------------- # #Por día hacemos un conteo de los casos que se confirmaron en cada estado # positivosXEstaXDia <- confirm %>% # dplyr::group_by(`ENTIDAD_RES`, `FECHA_INGRESO`) %>% # mutate(POSITIVOS=n()) %>% # distinct(`FECHA_INGRESO`, .keep_all = TRUE) %>% # arrange(`FECHA_INGRESO`) %>% # select(`FECHA_INGRESO`, # `ENTIDAD_RES`, # `ENTIDAD_FEDERATIVA`, # `FECHA_DEF`, # `POSITIVOS`, # )# %>% # # add_column(SUMS=NA) # # #Para generar las tablas de cada uno de los estados con su conteo # for(i in unique(positivosXEstaXDia$`ENTIDAD_RES`)) { # nam <- paste0("positivoE.", i ) # assign(nam, positivosXEstaXDia[positivosXEstaXDia$`ENTIDAD_RES`==i,]) # # } # # muertesXEstaXDia <- muertesConfirm %>% # dplyr::group_by(`ENTIDAD_RES`, `FECHA_INGRESO`) %>% # mutate(MUERTES=n()) %>% # distinct(`FECHA_INGRESO`, .keep_all = TRUE) %>% # arrange(`FECHA_INGRESO`) %>% # select(`FECHA_INGRESO`, # `ENTIDAD_RES`, # `ENTIDAD_FEDERATIVA`, # `FECHA_DEF`, # `MUERTES` # ) # for(i in unique(muertesXEstaXDia$`ENTIDAD_RES`)) { # nam <- paste("muertesE", i, sep = ".") # assign(nam, muertesXEstaXDia[muertesXEstaXDia$ENTIDAD_RES==i,]) # } # pruebasXEstaXDia <- filtroPrueba %>% # dplyr::group_by(`ENTIDAD_RES`, `FECHA_INGRESO`) %>% # mutate(PRUEBAS=n()) %>% # distinct(`FECHA_INGRESO`, .keep_all = TRUE) %>% # arrange(`FECHA_INGRESO`) %>% # select(`FECHA_INGRESO`, # `ENTIDAD_RES`, # `ENTIDAD_FEDERATIVA`, # `FECHA_DEF`, # `PRUEBAS`) # for(i in unique(pruebasXEstaXDia$`ENTIDAD_RES`)) { # nam <- paste("pruebasE", i, sep = ".") # assign(nam, pruebasXEstaXDia[pruebasXEstaXDia$ENTIDAD_RES==i,]) # # add_column(rollsumr("pruebasE".i$PRUEBAS, k = 14, fill = NA)) # # pruebasE.i$promedio <- rollmean(`PRUEBAS`, k = 14, fill = NA, aling="rigth") # } # for (i in tibble("pruebasE", i,sep="·")){ # tibble("pruebasE", i,sep="·")$sums <-rollsumr(PRUEBAS, k = 14, fill = NA) %>% # tibble("pruebasE", i,sep="·")$promedio <- rollmean(PRUEBAS, k = 14, fill = NA, aling="rigth") # } # Promedio al día indicadores por estados ------------------------------------------------------------- positivosXEstados <- confirm %>% group_by(`ENTIDAD_RES`) %>% mutate(Positivos=n()) %>% distinct(`ENTIDAD_RES`, .keep_all = TRUE) %>% arrange(`ENTIDAD_RES`) %>% dplyr::select( `ENTIDAD_RES`, `ENTIDAD_FEDERATIVA`, `ABREVIATURA`, `Positivos`) # #gestapo positivos al día en cada estado # positivosXEstaXDia <- positivosXEstaXDia %>% # ungroup() %>% # group_by(`ENTIDAD_RES`) %>% # mutate( # PROM=mean(POSITIVOS) # # ) muertesXEstado <- muertesConfirm %>% group_by(`ENTIDAD_RES`) %>% mutate(Muertes=n()) %>% distinct(`ENTIDAD_RES`, .keep_all = TRUE) %>% arrange(`ENTIDAD_RES`) %>% dplyr::select(`ENTIDAD_RES`, `ENTIDAD_FEDERATIVA`, `ABREVIATURA`, `Muertes`) # #promedios de muertes al día en cada estado # muertesXEstaXDia <- muertesXEstaXDia %>% # ungroup() %>% # group_by(`ENTIDAD_RES`) %>% # mutate( # PROM=mean(MUERTES) # # ) pruebasXEstado <- filtroPrueba %>% group_by(`ENTIDAD_RES`) %>% mutate(Pruebas=n()) %>% distinct(`ENTIDAD_RES`, .keep_all = TRUE) %>% arrange(`ENTIDAD_RES`) %>% dplyr::select(`ENTIDAD_RES`, # selección de datos necesarios `ENTIDAD_FEDERATIVA`, `ABREVIATURA`, `Pruebas`) # Por millon de habitantes ------------------------------------------------ posiXEstaXMillon <- ((1000000*positivosXEstados$Positivos)/poblacionEstado$pop) muerteXEstaXMillon <- ((1000000*muertesXEstado$Muertes)/poblacionEstado$pop) # Positividad ------------------------------------------------------------ PositividadIndica <- (positivosXEstados$Positivos/pruebasXEstado$Pruebas)*100 # Pruebas por mil habitantes --------------------------------------------- pruebasXEstaXMilhab <- ((1000*pruebasXEstado$Pruebas)/poblacionEstado$pop) # Tabla con datos finales xEstado ------------------------------------------------- indicadoresFinal <- positivosXEstados %>% tibble::add_column(muertesXEstado$Muertes) %>% tibble::add_column(pruebasXEstado$Pruebas) %>% tibble::add_column(posiXEstaXMillon) %>% tibble::add_column(muerteXEstaXMillon) %>% tibble::add_column(PositividadIndica) %>% tibble::add_column(pruebasXEstaXMilhab) indicadoresFinal <- indicadoresFinal %>% ungroup() %>% group_by(`ENTIDAD_FEDERATIVA`) %>% mutate( SUM= sum(`Positivos`, `muertesXEstado$Muertes`, posiXEstaXMillon, muerteXEstaXMillon, PositividadIndica, pruebasXEstaXMilhab, na.rm = TRUE), PROM = (SUM/6) ) PromIndica <- indicadoresFinal %>% dplyr::select(`ENTIDAD_RES`, `ENTIDAD_FEDERATIVA`, `PROM`) # summary(PromIndica) # Normalización ---------------------------------------------------------- # library(caret) # # # preproc2 <- preProcess(PromIndica[,c(1:3)], method=c("range")) # # norm2 <- predict(preproc2, PromIndica[,c(1:3)]) # # summary(norm2) normalize <- function(x) { return (((x - min(x))*(100) / (max(x) - min(x)))) } calificacion <- function(x) { return (100-(((x - min(x))*(100) )/ (max(x) - min(x)))) } PromIndica$NORM <- normalize(PromIndica$PROM) PromIndica$AVERAGE <- calificacion(PromIndica$PROM) # Tabla Calificación ----------------------------------------------------- calif <- PromIndica %>% dplyr::select(`ENTIDAD_FEDERATIVA`, `AVERAGE` ) %>% arrange(desc(AVERAGE)) colnames(calif)[colnames(calif)=="ENTIDAD_FEDERATIVA"] <- "ESTADO" ``` ```{r} #Tabla que muestra el número de pruebas que se hacen por día en los estados formattable(calif, #llamo datos align =c("l","c"), #Para alinear los datos de la tabla cada "" es una columna list(`ESTADO` = formatter( #datos específicos "span", style = ~ formattable::style(color = "grey",font.weight = "bold")), `AVERAGE` = color_tile("transparent", "orange")# me crea una barra roja con proporción a los datos ) ) ``` Comparativa entre países (Contagios) ========================================= ```{r} #Carga de datos que se necesitan para generar los datos de este sección nuevos_casos_mundiales <- read_csv("https://raw.github.com/owid/covid-19-data/master/public/data/jhu/full_data.csv") casos_por_millon <- read_csv("https://raw.githubusercontent.com/owid/covid-19-data/master/public/data/jhu/new_cases_per_million.csv") # creación de variables que se necesitan para esta sección #vector para la selección de paises con población similar poblacion_similiar <- c("Mexico", "Japan", "Russia", "Bangladesh", "Philippines") #Paises de LATAM latam <- c("Mexico", "Argentina", "Colombia", "Chile", "Brazil", "Bolivia", "Costa Rica", "Ecuador", "Guatemala", "Panama", "Paraguay", "Peru", "Puerto Rico", "Dominican Republic") #Para la grafica GraphLatam Comparativa_casos_latam <- casos_por_millon %>% dplyr::select(date, matches(latam)) %>% pivot_longer( cols = 'Mexico':'Dominican Republic', names_to = "Paises", values_to = "Casos_por_millon" ) %>% filter( Paises != "Ecuador") Comparativa_casos_latam_tsbl<- Comparativa_casos_latam %>% as_tsibble( index = date, key = Paises ) ``` Column ------------------------------------ ### Escenario mundial (población similar) ```{r} Comparativa_nuevos_casos <- nuevos_casos_mundiales %>% ggplot(aes(x = date, y = new_cases, group = location)) + geom_line(color = "grey") + geom_line(data = nuevos_casos_mundiales %>% filter(location %in% poblacion_similiar), aes(color = location), size = 1) + scale_y_log10() Comparativa_nuevos_casos ``` Column ------------------------------------ ### Escenario LATAM ```{r} GraphLatam <- Comparativa_casos_latam_tsbl %>% filter(Paises != "Ecuador") %>% #Se elimina ecuador de la lista de paises por datos críticos negativos as_tsibble( index = date )%>% ggplot() + geom_line(mapping = aes(x = date, y = Casos_por_millon, color = Paises)) + facet_wrap(~ Paises, scales = "free_y") + theme(legend.position = "none") GraphLatam ``` Vacunación en LATAM ========================================= ```{r} #Datos de manejo y de carga para generar las visualizaciones en esta seccion #carga de datos #Se importan los datos como un tibble Vacunastotales <- readr::read_csv("https://raw.githubusercontent.com/owid/covid-19-data/master/public/data/vaccinations/vaccinations.csv") #wrangle #Se quiere trabajar con series de tiempo, entonces convertimos # a tsibble un objeto que tiene orientación a este tiempo de #procesamiento Vacunastotales_tsibble <- Vacunastotales %>% dplyr::mutate(Daily = as.Date(date)) %>% dplyr::select(-date) %>% tsibble::as_tsibble(key = location, index = Daily) #se hace una variable con los nombres de los paises de #LATAM para asi poder llamar la variable a buscar en #la base de datos si se requiere, esto esta pensado #en que la instrucción podría hacerse varias veces #entonces en teoría debería simplificar el código latam <- c("Mexico", "Argentina", "Colombia", "Chile", "Brazil", "Bolivia", "Costa Rica", "Ecuador", "Guatemala", "Panama", "Paraguay", "Peru", "Puerto Rico", "Dominican Republic") #Se encontro que era particularmente complicado mostrar #todos los datos en una sola gráfica, por lo tanto, #graficar por secciones y pegar con patchwork es una #opción viable, por lo que la variable length(latam) = 14 #entonces dividimos en 2 grupos para tener símetria. latam1 <- latam[1:7] latam2 <- latam[8:14] #latam == latam1 + latam2 #hacemos otro data frame que solo sea para los de #LATAM y asi trabajamos con un tsibble más pequeña Vacunas_latam_tsibble <- Vacunastotales_tsibble %>% dplyr::select( Daily, location, total_vaccinations, total_vaccinations_per_hundred, daily_vaccinations_per_million) %>% dplyr::filter(location %in% latam) #Tratando los valores faltantes y los que estan fuera de rango #VLT = contracción para Vacunas_latam_tsibble VLT_miss <- Vacunas_latam_tsibble %>% #filter(location %in% latam1) %>% #anti_join(outliers) %>% tsibble::fill_gaps() #aqui se remplazan por valores faltantes #fill(direction = "down") #A continuacion hacemos un modelo ARIMA que se ajuste #a los datos que cotienen "valores faltantes" VLT_fill <- VLT_miss %>% fabletools::model(ARIMA(total_vaccinations_per_hundred)) %>% fabletools::interpolate(VLT_miss) ``` Row ------------------------------------ ### Escenario general ```{r} #Gráfica que representa el escenario general para los paises #de latam en el tiempo vacunados por cada 100 EscenarioLatam <- ggplot(data = Vacunas_latam_tsibble) + geom_line(mapping = aes(x = Daily, y = total_vaccinations_per_hundred, color = location)) + labs(x = 'meses', y = 'Vacunas aplicadas por cada 100') plotly::ggplotly(EscenarioLatam) #Notas de el gráifco EscenarioLatam #muestra una tendencia creciente #con temporalidad variable #No hay evidencia de comportmaiento ciclico # EscenarioLatam <- ggplot(data = Vacunas_latam_tsibble) + # geom_line(mapping = aes(x = Daily, y = total_vaccinations_per_hundred, color = location)) + # labs(title = 'Escenario general de vacunación en LATAM ', # x = 'meses', # y = 'Vacunas aplicadas por cada 100') # # #Gráfica que representa el escenario general para los paises # #de latam en el tiempo vacunados por cada 100 (rellenado) # # EscenarioLatam_fill <- ggplot(data = VLT_fill) + # geom_line(mapping = aes(x = Daily, y = total_vaccinations_per_hundred, color = location)) + # labs(title = 'Escenario general de vacunación en LATAM (sin valores faltantes)', # x = 'meses', # y = 'Vacunas aplicadas por cada 100') # # EscenarioLatam_Comparacion = EscenarioLatam + EscenarioLatam_fill # # EscenarioLatam_Comparacion ``` ### Estacionalidad (Mensual) ```{r} # #Visualización por periocidad ------------------------------------------- #Utilizando la función gg_season para hacer graficas #de la vacunación (2 gráficas por pais correspondiente a los # 2 años de los que se tienen datos) por mes. Vacunas_latam_tsibble %>% filter(location %in% latam1) %>% gg_season(total_vaccinations_per_hundred, labels = "both") + labs(y = "Vacunas aplicadas por cada 100", x = "Meses", title = "Vacunación por meses en los diferentes paises de LATAM") + expand_limits(x = ymd(c("2021-02","2021-04"))) -> g1 #se repite el codigo para hacer lo mismo y luego juntarlos #con el apoyo de patch work Vacunas_latam_tsibble %>% filter(location %in% latam2) %>% gg_season(total_vaccinations_per_hundred, labels = "both") + labs(y = "Vacunas aplicadas por cada 100", x = "Meses", title = "Vacunación por meses en los diferentes paises de LATAM") + expand_limits(x = ymd(c("2021-02","2021-04"))) -> g2 #No se estiliza que la asignación vaya hasta el final #pues transgrede con el estilo del código, pero se recomienda #en el libro de forescasting para darle "fluidez" a la lectura #del código #Se encuentra interesante que en marzo la mayoría de los paises #tienen una linea constante #Méxio y chile empezaron la vacunación en las últimas semanas #de diciembre # Visualización: Integración de los gráficos con PATCHWORK ----------------------------- #Establecemos un layout, que es basicamente un # para los espacios en blanco, y letras #para los lugares que deseamos que ocupe la letra layout <- ' AAAABBBB AAAABBBB AAAABBBB ' #cambiamos el lugar de las letras en el layout por nuestrras gráficas wrap_plots(A = g1, B = g2, design = layout) ``` ### Estacionalidad (semanal por mes) ```{r} #Aquí vemos las gráficas anteriores más a detalle, pues podemos #ver en que semanas de cada mes hay crecimiento Vacunas_latam_tsibble %>% filter(location %in% latam1) %>% gg_season(total_vaccinations_per_hundred, period = "month") + labs(y = "Vacunas aplicadas por cada 100", x = "Estacionalidad semanal", title = "Vacunación por semanana cada mes en los paises de LATAM") + expand_limits(x = ymd(c("2021-02","2021-04"))) -> g3 #repetimos el código para la sección 2 Vacunas_latam_tsibble %>% filter(location %in% latam2) %>% gg_season(total_vaccinations_per_hundred, period = "month") + labs(y = "Vacunas aplicadas por cada 100", x = "Estacionalidad semanal", title = "Vacunación por semanana cada mes en los paises de LATAM") + expand_limits(x = ymd(c("2021-02","2021-04"))) -> g4 # Visualización: Integración de los gráficos con PATCHWORK ----------------------------- #Establecemos un layout, que es basicamente un # para los espacios en blanco, y letras #para los lugares que deseamos que ocupe la letra layout <- ' AAAABBBB AAAABBBB AAAABBBB ' #cambiamos el lugar de las letras en el layout por nuestrras gráficas wrap_plots(A = g3, B = g4, design = layout) ``` Vacunación en LATAM (Pronósticos) ========================================= Row ------------------------------------ ### TSLM ```{r} # Modelo TSLM ------------------------------------------------------------- #https://www.rdocumentation.org/packages/forecast/versions/8.14/topics/tslm #Descripción #Fit a linear model with time series components #tslm is used to fit linear models to time series including trend and seasonality components. # Definición del modelo #TSLM(total_vaccinations_per_hundred ~ trend()) # Entrenamiento del modelo (Estimación) fit_TSLM <- Vacunas_latam_tsibble %>% fabletools::model(Modelo_tendencia = TSLM(total_vaccinations_per_hundred ~ trend())) #Para datos rellenados fit_TSLM_fill <- VLT_fill %>% fabletools::model(Modelo_tendencia = TSLM(total_vaccinations_per_hundred ~ trend())) # Revisar el desempeño del modelo (evaluación) # Producir pronósticos #Se genera la tabla de pronósticos, el cual va ser #una tabla de tipo fable (objeto) es decir #forecasting table fcst_TSLM <- fit_TSLM %>% forecast(h = 15) #se hace para los siguientes 3 meses #pues los datos que se tienen hasta el momento # son de 4 - 5 meses #tabla de pronósticos, datos rellenados fcst_TSLM_fill <- fit_TSLM_fill %>% forecast(h = 15) # # Visualización de la forecasting table (OLD) # # #para grupo 1 latama # # fcst_TSLM %>% # dplyr::filter(location %in% latam1) %>% # autoplot(Vacunas_latam_tsibble) + # ggtitle('Vacunas en LATAM') + # ylab('Vacunas aplicadas por cada 100') -> fcst_TSLM_g1 # # #para grupo 1 latam (rellenado) # # fcst_TSLM_fill %>% # dplyr::filter(location %in% latam1) %>% # autoplot(VLT_fill) + # ggtitle('Vacunas en LATAM') + # ylab('Vacunas aplicadas por cada 100') -> fcst_TSLM_fill_g1 # # #para grupo 2 latam # # fcst_TSLM %>% # dplyr::filter(location %in% latam2) %>% # autoplot(Vacunas_latam_tsibble) + # ggtitle('Vacunas en LATAM') + # ylab('Vacunas aplicadas por cada 100') -> fcst_TSLM_g2 # # #para grupo 2 latam (rellenado) # # fcst_TSLM_fill %>% # dplyr::filter(location %in% latam2) %>% # autoplot(VLT_fill) + # ggtitle('Vacunas en LATAM') + # ylab('Vacunas aplicadas por cada 100') -> fcst_TSLM_fill_g2 #visualización forescatsing table (new) #latam sin rellenar fcst_TSLM %>% autoplot(Vacunas_latam_tsibble) + facet_wrap(~location, ncol = 3, scales = 'free_y') + ggtitle('Vacunas en LATAM') + ylab('Vacunas aplicadas por cada 100') -> fcst_TSLM_g1 #latam rellenado fcst_TSLM_fill %>% autoplot(VLT_fill) + facet_wrap(~location, ncol = 3, scales = 'free_y') + ggtitle('Vacunas en LATAM') + ylab('Vacunas aplicadas por cada 100') -> fcst_TSLM_fill_g1 #integración de las visualizaciones fcst_TSLM_g3 = fcst_TSLM_g1 + fcst_TSLM_fill_g1 fcst_TSLM_g3 ``` ### ETS ```{r} # Modelo ETS (suavización exponencial con tendencia) ---------------------------- #https://www.rdocumentation.org/packages/forecast/versions/8.14/topics/ets #ETS = Exponential smoothing state space model #Description # Returns ETS model applied to "y" #Parámetros estimados #Estimamos alfa (entre 0 y 1, la tasa a la que disminuye "el peso" de los datos en el modelo, tambien conocida como el parametro de suavizacion) #L0 o Lt (nivel, o valor suavizado) #Beta (entre 0 y 1, es el coefficiente que representa la pendiente de la "tendencia" ) # 'A' es para 'aditivo' , 'M' para multiplicativo y 'N' para ninguno # Como nuestros datos tienen una tendencia marcada, seleccionmos que tanto #el error como la tendencia sean "aditivos" fit_ETS_trend <- VLT_fill %>% model(ETS(total_vaccinations_per_hundred ~ error('A') + trend('A') + season('N'))) #Generamos el pronóstico para 5 pasos después fcst_ETS_trend <- fit_ETS_trend %>% forecast(h = 15) %>% autoplot(VLT_fill) + facet_wrap(~location, ncol = 3, scales = 'free_y') + labs(title = 'Pronóstico (modelo ETS)', x = 'meses', y = 'Vacunas aplicadas por cada 100') -> fcst_ETS_trend_g1 #El método de Holt es el que nos permite hacer suavizacion #exponencial para datos con tendencia #Holt tiene un problema, que la tendencia solo se establece #como creciente o decreciente. Por lo que se desarrollo #una funcion que hace este metodo pero amortiguado # phi es el factor de "amortiguamiento", donde phi # con un valor igual a 1, es identico al metodo de Holt sin # amortiguamiento #Ad -> aditive damped fit_ETS_trendDamped <- VLT_fill %>% model(ETS(total_vaccinations_per_hundred ~ error('A') + trend('Ad') + season('N'))) fcst_ETS_trendDamped <- fit_ETS_trendDamped %>% forecast(h = 15) %>% autoplot(VLT_fill) + facet_wrap(~location, ncol = 3, scales = 'free_y') + labs(title = 'Pronóstico (ETS amortiguado)', x = 'meses', y = 'Vacunas aplicadas por cada 100') -> fcst_ETS_trendDamped_g1 fcst_ETS_comparacion = fcst_ETS_trend_g1 + fcst_ETS_trendDamped_g1 fcst_ETS_comparacion ```